No se ha buscado la relacion entre habilidades cognitivas, crecimiento y salud de los huesos utilizando los datos del estudio longitudinal de la UVG y los estudios que se han realizado con datos parecidos no han sido bien investigados en paises de bajos y medianos ingresos.
Los datos utilizados para este analisis son el producto de un estudio longitudinal diseñado por el Dr. Barry Bogin hace mas de 50 años en conjunto con el Colegio Americano de Guatemala. Ellos se propusieron a colectar datos longitudinalmente de estudiantes de todos los años y darle seguimiento a su crecimiento de forma anual hasta el momento en el que completaban sus estudios de bachillerato. El estudio se expandió a 6 colegios más a lo largo de los años y se cuenta con datos de peso, talla, IQ, pruebas de lectura y masa osea para registros comenzando en el año 1953.
Esta base de datos pertenece a la fundación Bill and Melinda Gates, los cuales donaron los fondos necesarios para digitalizarla.
subjects = as.data.table(read_xlsx("./data/1-Subjects sex_ID_school_DOB.xlsx"))
card1 = as.data.table(read_xlsx("./data/4-Card1.xlsx"))
card2 = as.data.table(read_xlsx("./data/5-Card2.xlsx"))En las tres bases de datos existen registros de control de digitalizacion como.
entering date: Fecha en la que los datos fueron digitalizados.User : Usuario que digitalizó el dato.Estas variables, por ser solo de control, junto a Repetition en Card1 y Card2, que no esta presente en casi todo el conjunto de datos, seran desechadas.
En Subjects podemos encontrar las siguientes variables personales de cada sujeto de estudio.
ID: Identificador personal para cada persona involucrada en el set de datos.DOB: Fecha de nacimiento de la persona.DOB decimal: Año de nacimiento de la persona en representacion decimal.Sex: Sexo de la persona.IdSchool 1: Identificador del colegio al que asistió la persona.IdSchool 2: Valor booleano que representa si el sujeto ya no estudia en el colegio representado en IdSchool 1En Card1 podemos encontrar las siguientes caracteristicas fisiologicas de los sujetos de observacion.
yearCard1: Año en el que se recopilaron los datos.gradeCard1: Grado escolar al que pertenecía la persona.Height: Altura de la persona en centimetros.Weight: Peso de la persona en kg.Hand grip: Fuerza de la mano calculado en kg.Dental: Dentición piezas del sujeto. Número de piezas permanentes eruptadas.En Card2 podemos encontrar las siguientes caracteristicas fisiologicas de los sujetos de observacion.
yearCard2: Año en el que se recopilaron los datos.grade Card 2: Grado escolar al que pertenecía la persona.UAC1: Circunferencia Tricep 1UAC2: Circunferencia Tricep 2TST1: Pliegue Cutáneo Tricep 1TST2: Pliegue Cutáneo Tricep 2SSF1: Pliegue Cutáneo Subescapular 1SSF2: Pliegue Cutáneo Subescapular 2mainData = subjects
c1 = card1
c2 = card2
colnames(mainData)[1] <- "Id"
colnames(c1)[2] <- "date"
colnames(c2)[2] <- "date"
cards <- merge(c1, c2, by = c("Id", "date"))
completeData <- merge(mainData, cards, by = "Id")
completeData$age <- round(completeData$date - completeData$`DOB decimal`, 0)ggplot(completeData, aes(x = age)) +
geom_bar() +
labs(x = "Edad", y = "Frecuencia")ggplot(completeData, aes(group = age, x = age, y = Height)) +
geom_boxplot() +
labs(x = "Edad", y = "Altura (cm)")Las alturas de más de 250 cm no tienen sentido. Además, las edades mayores a 22 años tienen muy pocos datos. Se decidió removerlos:
completeData <- completeData %>%
filter(Height < 250) %>%
filter(age < 23)ggplot(completeData, aes(group = age, x = age, y = Height)) +
geom_boxplot() +
labs(x = "Edad", y = "Altura (cm)")ggplot(completeData, aes(group = age, x = age, y = Weight)) +
geom_boxplot() +
labs(x = "Edad", y = "Peso (kg)")Pesos mayores a 200 kg no tienen sentidos. Se decidió eliminarlos:
completeData <- completeData %>%
filter(Weight < 200)ggplot(completeData, aes(group = age, x = age, y = Weight)) +
geom_boxplot() +
labs(x = "Edad", y = "Peso (kg)")for(i in 4:22){
temp <- completeData %>%
filter(age == i)
print(ggplot(temp, aes(x = Weight, y = Height)) + geom_point() +
labs(x = "Peso (kg)", y = "Altura (cm)", title = paste(i, " anos")) +
geom_smooth(method = lm, se = F))
}Solo existen 4 datos para mediciones con cuatro años de edad. Se eliminarán:
completeData <- completeData %>%
filter(age > 4)ggplot(completeData, aes(group = Dental, x = Dental, y = Height)) +
geom_boxplot() +
labs(x = "Número de dientes", y = "Altura (cm)")No tiene sentido que hayan niños tan altos sin dientes permanentes “erupcionados”. Según la Asociación Dental de América, se espera que a partir de los 6-7 años por lo menos se hayan desarrollado los incisivos centrales. Probablemente esos “0”s signifiquen que no fue registrado el dato. Para comprobar cuántos registros de niños mayores años no tienen dientes permanentes “erupcionados”:
paste(round((nrow(filter(completeData, age > 7 & Dental == 0))
/ nrow(completeData) * 100),2), "%")## [1] "62.46 %"
Más del 60% de los datos no tienen ese registro, por lo que no se utilizará esta columna.
completeData <- completeData %>%
mutate(Dental = NULL)IdSchool2, que indica si se cambiaron de colegio parece tener muchos NAs. Chequear:
paste(round(nrow(filter(completeData, is.na(`IdSchool 2`))) /
nrow(completeData) * 100, 2), "%")## [1] "99.86 %"
Casi el 100% de los registros no poseen esta información. Se eliminará esta columna. Además, se eliminarán las columnas Repetition y RepetitionCard1 ya que estas proveen poca información acerca de la altura. Es más, los alumnos repitentes podrían distorsionar las predicciones.
colnames(completeData)[6] <- "IdSchool2"
completeData <- completeData %>%
mutate(IdSchool2 = NULL) %>%
mutate(Repetition = NULL) %>%
mutate(RepetitionCard1 = NULL)Visualizar los datos de pruebas de fuerza de agarre:
ggplot(completeData, aes(y = `Hand grip`, x = age, group = age)) +
geom_boxplot() +
labs(y = "fuerza de agarre (kg)", x = "Edad (años)")No existen registros de pruebas de fuerza de agarre en los que se superen los 100 kg de fuerza de agarre, por lo que se eliminarán los outliers y se vuelve a graficar:
completeData <- completeData %>%
filter(`Hand grip` < 100)ggplot(completeData, aes(y = `Hand grip`, x = age, group = age)) +
geom_boxplot() +
labs(y = "fuerza de agarre (kg)", x = "Edad (años)")for(i in 5:22){
temp <- completeData %>%
filter(age == i)
print(ggplot(temp, aes(x = `Hand grip`)) +
geom_bar() +
labs(y = "Frecuencia",
x = "fuerza de agarre (kg)",
title = paste(i, " años")
)
)
}La fuerza de agarre presenta una distribución aparentemente normal desde los 5 hasta los 14 años. Sin embargo, a partir de los 15 años y sobre todo entre los 17 y 19 años, se pueden observar claramente dos distribuciones que se traslapan. Esto indica que en estas edades la diferencia de fuerza de agarre es mucho más marcada. Se tendrá esto en cuenta para futuras predicciones.
Se eliminarán otras variables poco útiles como entering date, entering data y User. También se eliminarán DOB y DOB decimal debido a que ya se calculó la edad en cada registro.
completeData <- completeData %>%
mutate(`entering date` = NULL) %>%
mutate(`entering data` = NULL) %>%
mutate(User.x = NULL) %>%
mutate(User.y = NULL) %>%
mutate(DOB = NULL) %>%
mutate(`DOB decimal` = NULL)Se evalurá la factibilidad de realizar un análisis de componentes principales utilizando la base de datos unificada del estudio.
pafDatos<-paf(as.matrix(completeData[,5:16]))
pafDatos$KMO## [1] 0.85819
pafDatos$Bartlett## [1] 2421661
summary(pafDatos)## $KMO
## [1] 0.85819
##
## $MSA
## MSA
## gradeCard1 0.83601
## Height 0.92163
## Weight 0.90310
## Hand grip 0.93607
## grade Card 2 0.83729
## UAC1 cm 0.80366
## UAC2 cm 0.80384
## TST1 mm 0.79714
## TST2 mm 0.79821
## SSF1 mm 0.82860
## SSF2 mm 0.82802
## age 0.97772
##
## $Bartlett
## [1] 2421661
##
## $Communalities
## Initial Communalities Final Extraction
## gradeCard1 0.98864 0.86969
## Height 0.91941 0.89379
## Weight 0.94778 0.91475
## Hand grip 0.87239 0.81608
## grade Card 2 0.98821 0.86286
## UAC1 cm 0.99593 0.57538
## UAC2 cm 0.99593 0.57583
## TST1 mm 0.95257 0.87040
## TST2 mm 0.95345 0.87526
## SSF1 mm 0.96472 0.85979
## SSF2 mm 0.96527 0.86265
## age 0.87765 0.87558
##
## $Factor.Loadings
## [,1] [,2]
## gradeCard1 0.83186 0.421540
## Height 0.86610 0.379030
## Weight 0.94769 0.128999
## Hand grip 0.79661 0.426023
## grade Card 2 0.82895 0.419168
## UAC1 cm 0.75196 -0.099723
## UAC2 cm 0.75240 -0.098627
## TST1 mm 0.62367 -0.693855
## TST2 mm 0.62832 -0.693163
## SSF1 mm 0.74177 -0.556386
## SSF2 mm 0.74497 -0.554685
## age 0.83275 0.426734
##
## $RMS
## [1] 0.06673
cortest.bartlett(completeData[,5:16])## $chisq
## [1] 2421661
##
## $p.value
## [1] 0
##
## $df
## [1] 66
Como se puede observar se obtuvo un KMO de 0.86 y un coeficiente de Bartlett muy elevado 2421661 por lo que parece que un analisis de componentes principales es una buena idea. Considerando que el valor P indicado es de 0.
kable(cor(completeData[,5:16],use = "pairwise.complete.obs"))| gradeCard1 | Height | Weight | Hand grip | grade Card 2 | UAC1 cm | UAC2 cm | TST1 mm | TST2 mm | SSF1 mm | SSF2 mm | age | |
|---|---|---|---|---|---|---|---|---|---|---|---|---|
| gradeCard1 | 1.00000 | 0.85642 | 0.80228 | 0.79474 | 0.99407 | 0.52634 | 0.52730 | 0.25657 | 0.26091 | 0.38685 | 0.39029 | 0.91085 |
| Height | 0.85642 | 1.00000 | 0.91494 | 0.89282 | 0.85281 | 0.58129 | 0.58226 | 0.29185 | 0.29662 | 0.42381 | 0.42747 | 0.88912 |
| Weight | 0.80228 | 0.91494 | 1.00000 | 0.87762 | 0.79881 | 0.67960 | 0.68011 | 0.49158 | 0.49587 | 0.65187 | 0.65517 | 0.82837 |
| Hand grip | 0.79474 | 0.89282 | 0.87762 | 1.00000 | 0.79096 | 0.56453 | 0.56529 | 0.17854 | 0.18261 | 0.36030 | 0.36338 | 0.82867 |
| grade Card 2 | 0.99407 | 0.85281 | 0.79881 | 0.79096 | 1.00000 | 0.52448 | 0.52544 | 0.25642 | 0.26075 | 0.38604 | 0.38954 | 0.90770 |
| UAC1 cm | 0.52634 | 0.58129 | 0.67960 | 0.56453 | 0.52448 | 1.00000 | 0.99796 | 0.49494 | 0.49773 | 0.55659 | 0.55872 | 0.53124 |
| UAC2 cm | 0.52730 | 0.58226 | 0.68011 | 0.56529 | 0.52544 | 0.99796 | 1.00000 | 0.49426 | 0.49723 | 0.55613 | 0.55844 | 0.53227 |
| TST1 mm | 0.25657 | 0.29185 | 0.49158 | 0.17854 | 0.25642 | 0.49494 | 0.49426 | 1.00000 | 0.97528 | 0.81731 | 0.81670 | 0.23896 |
| TST2 mm | 0.26091 | 0.29662 | 0.49587 | 0.18261 | 0.26075 | 0.49773 | 0.49723 | 0.97528 | 1.00000 | 0.81942 | 0.82167 | 0.24326 |
| SSF1 mm | 0.38685 | 0.42381 | 0.65187 | 0.36030 | 0.38604 | 0.55659 | 0.55613 | 0.81731 | 0.81942 | 1.00000 | 0.98156 | 0.39265 |
| SSF2 mm | 0.39029 | 0.42747 | 0.65517 | 0.36338 | 0.38954 | 0.55872 | 0.55844 | 0.81670 | 0.82167 | 0.98156 | 1.00000 | 0.39621 |
| age | 0.91085 | 0.88912 | 0.82837 | 0.82867 | 0.90770 | 0.53124 | 0.53227 | 0.23896 | 0.24326 | 0.39265 | 0.39621 | 1.00000 |
En la matriz de correlación observamos que algunas variables se encuentran relacionadas por lo que se procederá a realizar el analisis de componentes principales para intentar reducir el dataset.
compPrinc<-prcomp(completeData[,5:16], scale = T)
compPrinc## Standard deviations (1, .., p=12):
## [1] 2.747880 1.616276 0.945767 0.616485 0.530066 0.331774 0.289067
## [8] 0.191409 0.158106 0.134579 0.076765 0.045137
##
## Rotation (n x k) = (12 x 12):
## PC1 PC2 PC3 PC4 PC5 PC6
## gradeCard1 -0.30402 -0.269728 -0.17419177 0.386389 -0.234360 0.2861933
## Height -0.31566 -0.240491 -0.08544647 -0.166156 0.327941 -0.3019616
## Weight -0.34461 -0.082912 -0.06780173 -0.325511 0.198839 0.0312608
## Hand grip -0.29345 -0.277905 0.00034632 -0.438209 0.308244 0.4483749
## grade Card 2 -0.30323 -0.268916 -0.17535250 0.394547 -0.241602 0.3021934
## UAC1 cm -0.28731 0.071474 0.63307756 0.081034 -0.067685 -0.0190826
## UAC2 cm -0.28746 0.070688 0.63273700 0.081282 -0.067764 -0.0203844
## TST1 mm -0.22837 0.437769 -0.14810593 0.290329 0.381329 0.0292302
## TST2 mm -0.22992 0.436513 -0.14859961 0.285664 0.373207 0.0262647
## SSF1 mm -0.27187 0.351788 -0.17273338 -0.296650 -0.416498 -0.0087179
## SSF2 mm -0.27294 0.350316 -0.17240415 -0.294025 -0.412101 -0.0110911
## age -0.30416 -0.272437 -0.14929806 0.126191 -0.086260 -0.7287328
## PC7 PC8 PC9 PC10 PC11
## gradeCard1 0.0918366 3.7745e-03 -0.00113199 0.0021659 7.1407e-01
## Height 0.6014369 -4.9689e-01 -0.01484548 -0.0059592 -2.2446e-03
## Weight 0.2623324 8.0877e-01 0.01339201 0.0131188 -3.7436e-03
## Hand grip -0.5351493 -2.4934e-01 0.00010077 -0.0041179 -1.0911e-03
## grade Card 2 0.0982152 -1.2631e-05 -0.00049849 -0.0021059 -6.9998e-01
## UAC1 cm 0.0050754 -1.2907e-02 -0.00370159 0.0029173 -1.7807e-04
## UAC2 cm 0.0059720 -1.4720e-02 0.00257875 -0.0029193 2.0569e-04
## TST1 mm -0.0957052 1.9579e-03 -0.68737781 -0.1485137 2.3840e-06
## TST2 mm -0.0847347 -2.9944e-02 0.69407875 0.1520099 -1.7301e-04
## SSF1 mm 0.0145549 -1.2420e-01 -0.15578984 0.6863127 -1.2298e-03
## SSF2 mm 0.0175293 -1.0822e-01 0.14513340 -0.6953813 3.0119e-03
## age -0.4980667 9.1534e-02 0.00326062 0.0023756 -9.7776e-03
## PC12
## gradeCard1 -2.7453e-04
## Height -1.3946e-03
## Weight 8.6385e-04
## Hand grip 3.2365e-04
## grade Card 2 9.3014e-05
## UAC1 cm -7.0699e-01
## UAC2 cm 7.0720e-01
## TST1 mm 2.6839e-03
## TST2 mm -2.2620e-03
## SSF1 mm 3.5020e-03
## SSF2 mm -3.5226e-03
## age -4.8634e-04
summary(compPrinc)## Importance of components:
## PC1 PC2 PC3 PC4 PC5 PC6 PC7
## Standard deviation 2.748 1.616 0.9458 0.6165 0.5301 0.33177 0.28907
## Proportion of Variance 0.629 0.218 0.0745 0.0317 0.0234 0.00917 0.00696
## Cumulative Proportion 0.629 0.847 0.9215 0.9531 0.9766 0.98573 0.99269
## PC8 PC9 PC10 PC11 PC12
## Standard deviation 0.19141 0.15811 0.13458 0.07677 0.04514
## Proportion of Variance 0.00305 0.00208 0.00151 0.00049 0.00017
## Cumulative Proportion 0.99575 0.99783 0.99934 0.99983 1.00000
compPrincPCA<-PCA(completeData[,5:16],ncp=ncol(completeData[,5:16]), scale.unit = T)library(factoextra)
library(cluster)
cluster = completeData[,c('Sex','gradeCard1','Height','Weight','Hand grip','UAC1 cm','TST1 mm','SSF1 mm','age')]
cluster$Sex = as.factor(cluster$Sex)
cluster$Sex = as.numeric(cluster$Sex)
set.seed(12)
wss <- (nrow(cluster[,c()])-1)*sum(apply(cluster[,1:ncol(cluster)],2,var))
for (i in 2:10)
wss[i] <- sum(kmeans(cluster[,1:ncol(cluster)], centers=i)$withinss)
plot(2:
10, wss[c(2:10)], type="b", xlab="Number of Cluster", ylab="Squares Summatory", main = "Diagrama de Codo")require("fpc")
library(cluster)
set.seed(90)
km = kmeans(cluster, 4)
cluster$grupo<-km$cluster
completeData$grupo = km$cluster
g1 = completeData[cluster$grupo == 1,]
g2 = completeData[cluster$grupo == 2,]
g3 = completeData[cluster$grupo == 3,]
g4 = completeData[cluster$grupo == 4,]
plotcluster(cluster[,c(1:9)],cluster$grupo)ggplot(data = completeData, aes(group = grupo, y = age, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Edad") + ylim(c(0,25))ggplot(data = completeData, aes(group = grupo, y = Height, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Altura (cm)") + ylim(c(100,200))ggplot(data = completeData, aes(group = grupo, y = Weight, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Peso (kg)") + ylim(c(0,100))ggplot(data = completeData, aes(group = grupo, y = `Hand grip`, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Hand grip") + ylim(c(0,70))ggplot(data = completeData, aes(group = grupo, y = gradeCard1, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("Grado Escolar")ggplot(data = completeData, aes(group = grupo, y = `UAC1 cm`, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("UAC1 cm") + ylim(c(10,40))ggplot(data = completeData, aes(group = grupo, y = `TST1 mm`, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("TST1 mm") + ylim(c(0,35))ggplot(data = completeData, aes(group = grupo, y = `SSF1 mm`, fill = factor(grupo))) + geom_boxplot(outlier.shape = NA) + xlab("Grupos") + ggtitle("SSF1 mm") + ylim(c(0,35))barplot(prop.table(table(g1$Sex)))barplot(prop.table(table(g2$Sex)))barplot(prop.table(table(g3$Sex)))barplot(prop.table(table(g4$Sex)))ggplot(g1, aes(group = age, x = age, y = Height)) +
geom_boxplot() +
labs(x = "Edad", y = "Altura (cm)")ggplot(g2, aes(group = age, x = age, y = Height)) +
geom_boxplot() +
labs(x = "Edad", y = "Altura (cm)")ggplot(g3, aes(group = age, x = age, y = Height)) +
geom_boxplot() +
labs(x = "Edad", y = "Altura (cm)")ggplot(g4, aes(group = age, x = age, y = Height)) +
geom_boxplot() +
labs(x = "Edad", y = "Altura (cm)")ggplot(g1, aes(y = `Hand grip`, x = age, group = age)) +
geom_boxplot() +
labs(y = "fuerza de agarre (kg)", x = "Edad (anos)")ggplot(g2, aes(y = `Hand grip`, x = age, group = age)) +
geom_boxplot() +
labs(y = "fuerza de agarre (kg)", x = "Edad (anos)")ggplot(g3, aes(y = `Hand grip`, x = age, group = age)) +
geom_boxplot() +
labs(y = "fuerza de agarre (kg)", x = "Edad (anos)")ggplot(g4, aes(y = `Hand grip`, x = age, group = age)) +
geom_boxplot() +
labs(y = "fuerza de agarre (kg)", x = "Edad (anos)")ggplot(g1, aes(group = age, x = age, y = Weight)) +
geom_boxplot() +
labs(x = "Edad", y = "Peso (kg)")ggplot(g2, aes(group = age, x = age, y = Weight)) +
geom_boxplot() +
labs(x = "Edad", y = "Peso (kg)")ggplot(g3, aes(group = age, x = age, y = Weight)) +
geom_boxplot() +
labs(x = "Edad", y = "Peso (kg)")ggplot(g4, aes(group = age, x = age, y = Weight)) +
geom_boxplot() +
labs(x = "Edad", y = "Peso (kg)")